home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Source Code / C / Applications / Moscow ML 1.31 / source code / mosml / src / runtime / intern.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-07-03  |  15.7 KB  |  582 lines  |  [TEXT/R*ch]
  1. /* Structured input, fast format */
  2.  
  3. #include "debugger.h"
  4. #include "fail.h"
  5. #include "gc.h"
  6. #include "intext.h"
  7. #include "io.h"
  8. #include "memory.h"
  9. #include "mlvalues.h"
  10. #include "reverse.h"
  11.  
  12. /* Transform offsets relative to the beginning of the block 
  13.    back into pointers. */
  14.  
  15. static void adjust_pointers(start, size, color)
  16.      value *start;
  17.      mlsize_t size;
  18.      color_t color;
  19. {
  20.   value * p, * q;
  21.   mlsize_t sz;
  22.   header_t hd;
  23.   tag_t tag;
  24.   value v;
  25.   mlsize_t bosize;
  26.  
  27.   p = start;
  28.   q = p + size;
  29.   bosize = Bsize_wsize(size);
  30.   while (p < q) {
  31.     hd = *p;
  32.     sz = Wosize_hd(hd);
  33.     tag = Tag_hd(hd);
  34.     *p++ = Make_header(sz, tag, color);
  35.     if (tag >= No_scan_tag)
  36.       p += sz;
  37.     else
  38.       for( ; sz > 0; sz--, p++) {
  39.         v = *p;
  40.         switch(v & 3) {
  41.         case 0:                 /* 0 -> A bloc represented by its offset. */
  42.           Assert(v >= 0 && v <= bosize && (v & 3) == 0);
  43.           *p = (value) ((byteoffset_t) start + v);
  44.           break;
  45.         case 2:                 /* 2 -> An atom. */
  46.           v = v >> 2;
  47.           Assert(v >= 0 && v < 256);
  48.           *p = Atom(v);
  49.           break;
  50.         default:                /* 1 or 3 -> An integer. */
  51.           break;
  52.         }
  53.       }
  54.   }
  55. }
  56.  
  57. /* Reverse all words in a block, in case of endianness clash.
  58.    Works with words of the natural word size. */
  59.  
  60. void rev_pointers(p, size)
  61.      value *p;
  62.      mlsize_t size;
  63. {
  64.   value * q;
  65.   header_t hd;
  66.   mlsize_t n;
  67.  
  68.   q = p + size;
  69.   while (p < q) {
  70.     Reverse_word(p);
  71.     hd = (header_t) *p++;
  72.     n = Wosize_hd(hd);
  73.     switch(Tag_hd(hd)) {
  74.     case String_tag:
  75.       p += n;
  76.       break;
  77.     case Double_tag:
  78.       Reverse_double(p);
  79.       p += n;
  80.       break;
  81.     default:
  82.       for( ; n > 0; n--, p++) {
  83.         Reverse_word(p);
  84.       }
  85.     }
  86.   }
  87. }
  88.  
  89. #ifdef SIXTYFOUR
  90.  
  91. /* Routines to convert 32-bit externed objects to 64-bit memory blocks. */
  92.  
  93. typedef int32 value32;
  94.  
  95. /* Reverse all words in a block, in case of endianness clash.
  96.    Works with 32-bit words. */
  97.  
  98. void rev_pointers_32(p, size)
  99.      value32 * p;
  100.      mlsize_t size;
  101. {
  102.   value32 * q;
  103.   header_t hd;
  104.   mlsize_t n;
  105.  
  106.   q = p + size;
  107.   while (p < q) {
  108.     Reverse_int32(p);
  109.     hd = (header_t) *p++;
  110.     n = Wosize_hd(hd);
  111.     switch(Tag_hd(hd)) {
  112.     case String_tag:
  113.       p += n;
  114.       break;
  115.     case Double_tag:
  116.       Reverse_double(p);
  117.       p += n;
  118.       break;
  119.     default:
  120.       for( ; n > 0; n--, p++) {
  121.         Reverse_int32(p);
  122.       }
  123.     }
  124.   }
  125. }
  126.  
  127. /* Compute the size of the expansion of a 32-bit externed block to a
  128.    64-bit block. The size is returned in 64-bit words. */
  129.  
  130. static mlsize_t size_after_expansion(p, len)
  131.      value32 * p;
  132.      mlsize_t len;              /* length in 32-bit words */
  133. {
  134.   mlsize_t res;
  135.   value32 * q;
  136.   header_t hd;
  137.   mlsize_t n;
  138.  
  139.   for (q = p + len, res = 0; p < q; /*nothing*/) {
  140.     hd = (header_t) *p++;
  141.     res++;
  142.     n = Wosize_hd(hd);
  143.     switch(Tag_hd(hd)) {
  144.     case String_tag:            /* round to the next 64-bit word */
  145.       res += (n * sizeof(value32) + sizeof(value) - 1) / sizeof(value);
  146.       break;
  147.     case Double_tag:
  148.       res += sizeof(double) / sizeof(value);
  149.       break;
  150.     default:
  151.       res += n;                 /* all fields will be extended 32 -> 64 */
  152.       break;
  153.     }
  154.     p += n;
  155.   }
  156.   return res;
  157. }
  158.  
  159. /* Convert a 32-bit externed block to a 64-bit block. The resulting block
  160.    is a valid 64-bit object. */
  161.  
  162. static void expand_block(source, dest, source_len, dest_len, color)
  163.      value32 * source;
  164.      value * dest;
  165.      mlsize_t source_len, dest_len;
  166.      color_t color;
  167. {
  168.   value32 * p, * q;
  169.   value * d, * e;
  170.   header_t hd;
  171.   mlsize_t sz;
  172.   tag_t tag;
  173.   uint32 * forward_addr;
  174.   uint32 dest_ofs;
  175.   value v;
  176.  
  177.   /* First pass: copy the objects and set up forwarding pointers.
  178.      The pointers contained inside blocks are not resolved. */
  179.  
  180.   for (p = source, q = source + source_len, d = dest; p < q; /*nothing*/) {
  181.     hd = (header_t) *p++;
  182.     sz = Wosize_hd(hd);
  183.     tag = Tag_hd(hd);
  184.     forward_addr = (uint32 *) p;
  185.     dest_ofs = d + 1 - dest;
  186.     switch(tag) {
  187.     case String_tag:
  188.       { mlsize_t ofs_last_byte, len, new_sz;
  189.         ofs_last_byte = sz * sizeof(value32) - 1;
  190.         len = ofs_last_byte - Byte(p, ofs_last_byte);
  191.         new_sz = (sz * sizeof(value32) + sizeof(value) - 1) / sizeof(value);
  192.         *d++ = Make_header(new_sz, String_tag, color);
  193.         Field(d, new_sz - 1) = 0;
  194.         bcopy((char *)p, (char *)d, len);
  195.         ofs_last_byte = new_sz * sizeof(value) - 1;
  196.         Byte(d, ofs_last_byte) = ofs_last_byte - len;
  197.         p += sz;
  198.         d += new_sz;
  199.         break;
  200.       }
  201.     case Double_tag:
  202.       *d++ = Make_header(Double_wosize, Double_tag, color);
  203.       /* Cannot do *((double *) d) = *((double *) p) directly
  204.          because p might not be 64-aligned. */
  205.       Assert(sizeof(double) == sizeof(value));
  206.       ((value32 *) d)[0] = p[0];
  207.       ((value32 *) d)[1] = p[1];
  208.       p += sizeof(double) / sizeof(value32);
  209.       d += 1;
  210.       break;
  211.     default:
  212.       *d++ = Make_header(sz, tag, color);
  213.       for (/*nothing*/; sz > 0; sz--, p++, d++) {
  214.         if ((*p & 1) == 0) {
  215.           *d = *((uint32 *) p);         /* copy, zero expansion */
  216.         } else {
  217.           *d = *((int32 *) p);          /* copy, sign expansion */
  218.         }
  219.       }
  220.       break;
  221.     }
  222.     *forward_addr = dest_ofs;   /* store the forwarding pointer */
  223.   }
  224.   Assert(d == dest + dest_len);
  225.  
  226.   /* Second pass: resolve pointers contained inside blocks,
  227.      replacing them by the corresponding forwarding pointer. */
  228.  
  229.   for (d = dest, e = dest + dest_len; d < e; /*nothing*/) {
  230.     hd = (header_t) *d++;
  231.     sz = Wosize_hd(hd);
  232.     tag = Tag_hd(hd);
  233.     if (tag >= No_scan_tag) {
  234.       d += sz;
  235.     } else {
  236.       for (/*nothing*/; sz > 0; sz--, d++) {
  237.         v = *d;
  238.         switch(v & 3) {
  239.         case 0:                 /* 0: a block represented by its offset */
  240.           Assert(v >= 0 && v < source_len * sizeof(value32) && (v & 3) == 0);
  241.           *d = (value) (dest + *((uint32 *)((char *) source + v)));
  242.           break;
  243.         case 2:                 /* 2: an atom */
  244.           v = v >> 2;
  245.           Assert(v >= 0 && v < 256);
  246.           *d = Atom(v);
  247.           break;
  248.         default:                /* 1 or 3: an integer */
  249.           break;
  250.         }
  251.       }
  252.     }
  253.   }
  254. }
  255.  
  256. #else /* !SIXTYFOUR */
  257.  
  258. /* Routines to convert 64-bit externed objects to 32-bit memory blocks. */
  259.  
  260. struct value64_struct {
  261. #ifdef BIG_ENDIAN
  262.   value msw, lsw;
  263. #else
  264.   value lsw, msw;
  265. #endif
  266. };
  267. typedef struct value64_struct value64;
  268.  
  269. /* Reverse all words in a block, in case of endianness clash.
  270.    Works with 64-bit words.
  271.    Returns (-1) if a header too large is encountered, 0 otherwise. */
  272.  
  273. int rev_pointers_64(p, size)
  274.      value64 * p;
  275.      mlsize_t size;             /* size in 64-bit words */
  276. {
  277.   value64 * q;
  278.   header_t hd;
  279.   mlsize_t n;
  280.  
  281.   q = p + size;
  282.   while (p < q) {
  283.     Reverse_int64(p);
  284.     hd = (header_t)(p->lsw);
  285.     if (p->msw != 0) return -1;
  286.     p++;
  287.     n = Wosize_hd(hd);
  288.     switch(Tag_hd(hd)) {
  289.     case String_tag:
  290.       p += n;
  291.       break;
  292.     case Double_tag:
  293.       Reverse_double(p);
  294.       p += n;
  295.       break;
  296.     default:
  297.       for( ; n > 0; n --, p++) {
  298.         Reverse_int64(p);
  299.       }
  300.     }
  301.   }
  302.   return 0;
  303. }
  304.  
  305. /* Compute the size of the shrinkage of a 64-bit externed block to a
  306.    32-bit block. The size is returned in 32-bit words.
  307.    Return 0 if a block cannot be shrunk because its size is too big. */
  308.  
  309. static mlsize_t size_after_shrinkage(p, len)
  310.      value64 * p;
  311.      mlsize_t len;              /* length in 64-bit words */
  312. {
  313.   mlsize_t res;
  314.   value64 * q;
  315.   header_t hd;
  316.   mlsize_t n;
  317.  
  318.   for (q = p + len, res = 0; p < q; /*nothing*/) {
  319.     hd = (header_t)(p->lsw);
  320.     if (p->msw != 0) return 0;
  321.     p++;
  322.     n = Wosize_hd(hd);
  323.     res++;
  324.     switch(Tag_hd(hd)) {
  325.     case String_tag:
  326.       { mlsize_t ofs_last_byte, len, new_sz;
  327.         ofs_last_byte = n * sizeof(value64) - 1;
  328.         len = ofs_last_byte - Byte(p, ofs_last_byte);
  329.         new_sz = (len + sizeof(value)) / sizeof(value);
  330.         res += new_sz;
  331.         break;
  332.       }
  333.     case Double_tag:
  334.       res += sizeof(double) / sizeof(value);
  335.       break;
  336.     default:
  337.       res += n;                 /* all fields will be shrunk 64 -> 32 */
  338.       break;
  339.     }
  340.     p += n;
  341.   }
  342.   return res;
  343. }
  344.  
  345. /* Convert a 64-bit externed block to a 32-bit block. The resulting block
  346.    is a valid 32-bit object.
  347.    Return -1 if the block cannot be shrunk because some integer literals
  348.    or relative displacements are too large, 0 otherwise. */
  349.  
  350. static int shrink_block(source, dest, source_len, dest_len, color)
  351.      value64 * source;
  352.      value * dest;
  353.      mlsize_t source_len, dest_len;
  354.      color_t color;
  355. {
  356.   value64 * p, * q;
  357.   value * d, * e;
  358.   header_t hd;
  359.   mlsize_t sz;
  360.   tag_t tag;
  361.   byteoffset_t * forward_addr;
  362.   byteoffset_t dest_ofs;
  363.   value v;
  364.  
  365.   /* First pass: copy the objects and set up forwarding pointers.
  366.      The pointers contained inside blocks are not resolved. */
  367.  
  368.   for (p = source, q = source + source_len, d = dest; p < q; /*nothing*/) {
  369.     hd = (header_t)(p->lsw);
  370.     p++;
  371.     sz = Wosize_hd(hd);
  372.     tag = Tag_hd(hd);
  373.     forward_addr = (byteoffset_t *) p;
  374.     dest_ofs = d + 1 - dest;
  375.     switch(tag) {
  376.     case String_tag:
  377.       { mlsize_t ofs_last_byte, len, new_sz;
  378.         ofs_last_byte = sz * sizeof(value64) - 1;
  379.         len = ofs_last_byte - Byte(p, ofs_last_byte);
  380.         new_sz = (len + sizeof(value)) / sizeof(value);
  381.         *d++ = Make_header(new_sz, String_tag, color);
  382.         Field(d, new_sz - 1) = 0;
  383.         bcopy(p, d, len);
  384.         ofs_last_byte = new_sz * sizeof(value) - 1;
  385.         Byte(d, ofs_last_byte) = ofs_last_byte - len;
  386.         p += sz;
  387.         d += new_sz;
  388.         break;
  389.       }
  390.     case Double_tag:
  391.       *d++ = Make_header(Double_wosize, Double_tag, color);
  392.       Store_double_val((value)d, Double_val((value)p));
  393.       p += sizeof(double) / sizeof(value64);
  394.       d += sizeof(double) / sizeof(value);
  395.       break;
  396.     default:
  397.       *d++ = Make_header(sz, tag, color);
  398.       for (/*nothing*/; sz > 0; sz--, p++, d++) {
  399.         value lsw = p->lsw;
  400.         value msw = p->msw;
  401.         if ((lsw & 1) == 0) {      /* If relative displacement: */
  402.           if (msw != 0) return -1; /* Check unsigned displacement fits in 32 */
  403.         } else {                   /* Otherwise, it's a signed integer */
  404.           if ((lsw >= 0 && msw != 0) || (lsw < 0 && msw != -1)) return -1;
  405.         }
  406.         *d = lsw;
  407.       }
  408.     }
  409.     *forward_addr = dest_ofs;   /* store the forwarding pointer */
  410.   }
  411.   Assert(d == dest + dest_len);
  412.  
  413.   /* Second pass: resolve pointers contained inside blocks,
  414.      replacing them by the corresponding forwarding pointer. */
  415.  
  416.   for (d = dest, e = dest + dest_len; d < e; /*nothing*/) {
  417.     hd = (header_t) *d++;
  418.     sz = Wosize_hd(hd);
  419.     tag = Tag_hd(hd);
  420.     if (tag >= No_scan_tag) {
  421.       d += sz;
  422.     } else {
  423.       for (/*nothing*/; sz > 0; sz--, d++) {
  424.         v = *d;
  425.         switch(v & 3) {
  426.         case 0:                 /* 0: a block represented by its offset */
  427.           Assert(v >= 0 && v < source_len * sizeof(value64) && (v & 7) == 0);
  428.           *d = (value) (dest + *((byteoffset_t *)((char *) source + v)));
  429.           break;
  430.         case 2:                 /* 2: an atom */
  431.           v = v >> 2;
  432.           Assert(v >= 0 && v < 256);
  433.           *d = Atom(v);
  434.           break;
  435.         default:                /* 1 or 3: an integer */
  436.           break;
  437.         }
  438.       }
  439.     }
  440.   }
  441.   return 0;
  442. }
  443.  
  444. #endif /* SIXTYFOUR */
  445.  
  446. #ifdef BIG_ENDIAN
  447. #define Wrong_endian_32_magic_number Little_endian_32_magic_number
  448. #define Wrong_endian_64_magic_number Little_endian_64_magic_number
  449. #else
  450. #define Wrong_endian_32_magic_number Big_endian_32_magic_number
  451. #define Wrong_endian_64_magic_number Big_endian_64_magic_number
  452. #endif
  453.  
  454. static value intern_fast_val(chan, magic)
  455.      struct channel * chan;
  456.      unsigned long magic;
  457. {
  458.   value res;
  459.   mlsize_t whsize, wosize;
  460.   unsigned long bhsize;
  461.   color_t color;
  462.   header_t hd;
  463.  
  464.   whsize = getword(chan);
  465.   if (whsize == 0) {
  466.     res = (value) getword(chan);
  467.     if (Is_long(res))
  468.       return res;
  469.     else
  470.       return Atom(res >> 2);
  471.   }
  472.   bhsize = Bsize_wsize (whsize);
  473.   wosize = Wosize_whsize (whsize);
  474. #ifdef SIXTYFOUR
  475.   if (magic == Little_endian_32_magic_number ||
  476.       magic == Big_endian_32_magic_number) {
  477.     /* Expansion 32 -> 64 required */
  478.     mlsize_t whsize32;
  479.     value32 * block;
  480.     whsize32 = whsize;
  481.     block = (value32 *) stat_alloc(whsize32 * sizeof(value32));
  482.     if (really_getblock(chan, (char *) block,
  483.                         whsize32 * sizeof(value32)) == 0) {
  484.       stat_free((char *) block);
  485.       failwith ("intern : truncated object");
  486.     }
  487.     if (magic == Wrong_endian_32_magic_number)
  488.       rev_pointers_32(block, whsize32);
  489.     whsize = size_after_expansion(block, whsize32);
  490.     wosize = Wosize_whsize(whsize);
  491.     res = alloc_shr(wosize, String_tag);
  492.     hd = Hd_val (res);
  493.     color = Color_hd (hd);
  494.     Assert (color == White || color == Black);
  495.     expand_block(block, Hp_val(res), whsize32, whsize, color);
  496.     stat_free((char *) block);
  497.   } else {
  498.     /* Block has natural word size (64) */
  499.     res = alloc_shr(wosize, String_tag);
  500.     hd = Hd_val (res);
  501.     color = Color_hd (hd);
  502.     Assert (color == White || color == Black);
  503.     if (really_getblock(chan, Hp_val(res), bhsize) == 0) {
  504.       Hd_val (res) = hd;                      /* Avoid confusing the GC. */
  505.       failwith ("intern : truncated object");
  506.     }
  507.     if (magic == Wrong_endian_64_magic_number)
  508.       rev_pointers(Hp_val (res), whsize);
  509.     adjust_pointers(Hp_val (res), whsize, color);
  510.   }
  511. #else /* !SIXTYFOUR */
  512.   if (magic == Little_endian_64_magic_number ||
  513.       magic == Big_endian_64_magic_number) {
  514.     /* Shrinkage 64 -> 32 required */
  515.     mlsize_t whsize64;
  516.     value64 * block;
  517.     whsize64 = whsize;
  518.     block = (value64 *) stat_alloc(whsize64 * sizeof(value64));
  519.     if (really_getblock(chan, (char *) block, 
  520.                         whsize64 * sizeof(value64)) == 0) {
  521.       stat_free((char *) block);
  522.       failwith ("intern : truncated object");
  523.     }
  524.     if (magic == Wrong_endian_64_magic_number) {
  525.       if (rev_pointers_64(block, whsize64) == -1) {
  526.         stat_free((char *) block);
  527.         failwith("intern: 64-bit object too big");
  528.       }
  529.     }
  530.     whsize = size_after_shrinkage(block, whsize64);
  531.     if (whsize == -1) {
  532.       stat_free((char *) block);
  533.       failwith("intern: 64-bit component not representable");
  534.     }
  535.     wosize = Wosize_whsize(whsize);
  536.     if (wosize > Max_wosize)
  537.       failwith("intern: structure too big");
  538.     res = alloc_shr(wosize, String_tag);
  539.     hd = Hd_val (res);
  540.     color = Color_hd (hd);
  541.     Assert (color == White || color == Black);
  542.     if (shrink_block(block, Hp_val(res), whsize64, whsize, color) == -1) {
  543.       Hd_val (res) = hd;                      /* Avoid confusing the GC. */
  544.       stat_free((char *) block);
  545.       failwith("intern: 64-bit component not representable");
  546.     }
  547.     stat_free((char *) block);
  548.   } else {
  549.     /* Block has natural word size (32) */
  550.     if (wosize > Max_wosize)
  551.       failwith("intern: structure too big");
  552.     res = alloc_shr(wosize, String_tag);
  553.     hd = Hd_val (res);
  554.     color = Color_hd (hd);
  555.     Assert (color == White || color == Black);
  556.     if (really_getblock(chan, Hp_val(res), bhsize) == 0) {
  557.       Hd_val (res) = hd;                      /* Avoid confusing the GC. */
  558.       failwith ("intern : truncated object");
  559.     }
  560.     if (magic == Wrong_endian_32_magic_number)
  561.       rev_pointers(Hp_val (res), whsize);
  562.     adjust_pointers(Hp_val (res), whsize, color);
  563.   }
  564. #endif /* !SIXTYFOUR */
  565.   return res;
  566. }
  567.  
  568. value intern_val(chan)          /* ML */
  569.      struct channel * chan;
  570. {
  571.   value res;
  572.   unsigned long magic;
  573.  
  574.   magic = (uint32) getword(chan);
  575.   if (magic < First_valid_magic_number || magic > Last_valid_magic_number)
  576.     failwith("intern: bad object");
  577.   if (magic == Compact_magic_number)
  578.     return intern_compact_val(chan);
  579.   else
  580.     return intern_fast_val(chan, magic);
  581. }
  582.